home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / command.scm < prev    next >
Text File  |  1995-10-13  |  19KB  |  584 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; This is file command.scm.
  5.  
  6. ; Command processor.
  7.  
  8. ; The command processor's state is of three kinds:
  9. ; 1. User context - preserved across dump commands.
  10. ;    This includes the designated user and configuration environments.
  11. ; 2. Session state - one per "login"; not preserved across dump commands.
  12. ;    This includes ## and the command loop's interactive ports.
  13. ; 3. Command levels - one for each different command level.
  14. ;    This includes any condition being handled, and continuations.
  15.  
  16. (define command-prefix #\,)
  17.  
  18.  
  19. ; User context.
  20.  
  21. (define (make-user-context thunk)
  22.   (let ((t (make-table)))
  23.     (let-fluid $user-context t
  24.       (lambda ()
  25.         (for-each (lambda (name+thunk)
  26.                     (table-set! t (car name+thunk) ((cdr name+thunk))))
  27.                   *user-context-initializers*)
  28.         (thunk)
  29.         t))))
  30.  
  31. (define *user-context-initializers* '())
  32.  
  33. (define $user-context (make-fluid #f))
  34. ; (set-fluid! $user-context (make-user-context unspecific)) ;Bad for GC
  35. (define (user-context) (fluid $user-context))
  36.  
  37. (define (user-context-accessor name initializer)
  38.   (set! *user-context-initializers*
  39.         (append *user-context-initializers*
  40.                 (list (cons name initializer))))
  41.   (let ((probe (fluid $user-context)))
  42.     (if probe (table-set! probe name (initializer))))
  43.   (lambda ()
  44.     (table-ref (user-context) name)))
  45.  
  46. (define (user-context-modifier name)
  47.   (lambda (new)
  48.     (table-set! (user-context) name new)))
  49.  
  50.  
  51. ; Session state.
  52.  
  53. (define session-type
  54.   (make-record-type 'session '(input output values batch-mode? bow?)))
  55. (define make-session
  56.   (record-constructor session-type
  57.                       '(input output values batch-mode? bow?)))
  58. (define $session
  59.   (make-fluid (make-session (current-input-port)
  60.                             (current-output-port)
  61.                             '() #f #f)))
  62. (define (session-accessor name)
  63.   (let ((a (record-accessor session-type name)))
  64.     (lambda () (a (fluid $session)))))
  65. (define (session-modifier name)
  66.   (let ((m (record-modifier session-type name)))
  67.     (lambda (new) (m (fluid $session) new))))
  68. (define command-input (session-accessor 'input))
  69. (define command-output (session-accessor 'output))
  70. (define focus-values (session-accessor 'values))
  71. (define set-focus-values! (session-modifier 'values))
  72. (define batch-mode? (session-accessor 'batch-mode?))
  73. (define set-batch-mode?! (session-modifier 'batch-mode?))
  74. (define break-on-warnings? (session-accessor 'bow?))
  75. (define set-break-on-warnings?! (session-modifier 'bow?))
  76.  
  77.  
  78.  
  79. ; Command levels.
  80.  
  81. (define $command-levels (make-fluid '()))
  82. (define (command-level) (car (fluid $command-levels)))
  83.  
  84. (define :command-level
  85.   (make-record-type 'command-level
  86.                     '(throw vm-cont condition interrupts
  87.                 ;; env
  88.                 )))
  89. (define make-command-level
  90.   (record-constructor :command-level
  91.                       '(throw vm-cont condition interrupts
  92.                   ;; env
  93.                   )))
  94. (define command-level? (record-predicate :command-level))
  95. (define command-level-throw
  96.   (record-accessor :command-level 'throw))
  97. (define command-level-vm-cont
  98.   (record-accessor :command-level 'vm-cont))
  99. (define command-level-condition
  100.   (record-accessor :command-level 'condition))
  101. (define command-level-interrupts
  102.   (record-accessor :command-level 'interrupts))
  103. ;(define command-level-env
  104. ;  (record-accessor :command-level 'env))
  105. ;(define set-command-level-env!
  106. ;  (record-modifier :command-level 'env))
  107.  
  108. (define environment-for-commands interaction-environment)
  109.  
  110. ; --------------------
  111. ; Main entry point.
  112.  
  113. (define (with-user-context context thunk)
  114.   (let-fluid $user-context context thunk))    ; Log in.
  115.  
  116.  
  117. (define (with-new-session context iport oport resume-args batch? thunk)
  118.   (let-fluids $user-context context
  119.           $command-levels '()
  120.           $session (make-session iport oport resume-args batch? #f)
  121.     thunk))
  122.  
  123.  
  124. ;; The double-paren around the w-n-s is because it returns a continuation
  125. ;; which is the thing to do after the command-processor exits.
  126.  
  127. (define (start-command-processor resume-args context
  128.                  ;; initial-env
  129.                  start-thunk)
  130.   (interrupt-before-heap-overflow!)
  131.   ((with-new-session context
  132.              (current-input-port) (current-output-port)
  133.              resume-args (and (pair? resume-args)
  134.                       (equal? (car resume-args) "batch"))
  135.      (lambda ()
  136.        (command-loop start-thunk #f
  137.              ;; initial-env
  138.              )))))
  139.  
  140. ; Entry for initialization & testing.
  141.  
  142. (define (command-processor command-env args) 
  143.   (start-command-processor args
  144.                            (make-user-context
  145.                 (lambda ()
  146.                   (set-user-command-environment! command-env)))
  147.                            ;; (interaction-environment)
  148.                            unspecific))
  149.  
  150. ; Command loop
  151. ; Uses:
  152. ;  1. startup, 2. condition handler, 3. abort-to-level, 4. breakpoint
  153.  
  154. (define (command-loop start-thunk condition
  155.               ;; env
  156.               )
  157.   (call-with-command-level condition ;; env
  158.     (lambda (level)
  159.       (start-command-level start-thunk level))))
  160.  
  161. (define (call-with-command-level condition
  162.                  ;; env
  163.                  proc)
  164.   (primitive-catch
  165.     (lambda (vm-cont)
  166.       ((call-with-current-continuation
  167.          (lambda (throw)
  168.            (proc (make-command-level throw vm-cont condition
  169.                                      (enabled-interrupts)
  170.                                      ;; env
  171.                      ))))))))
  172.  
  173. (define (start-command-level start-thunk level)
  174.   (with-handler command-loop-condition-handler
  175.     (lambda ()
  176.       (let-fluids $command-levels (cons level (fluid $command-levels))
  177.                   $note-undefined #f    ;useful
  178.         (lambda ()
  179.           ;;(with-interaction-environment (command-level-env level)
  180.             ;;(lambda ()
  181.               (start-thunk)
  182.               (let ((condition (command-level-condition level)))
  183.                 (if condition
  184.                     (display-condition condition (command-output)))
  185.                 (if (not (= (enabled-interrupts) all-interrupts))
  186.                     (begin (if (not (and (interrupt? condition)
  187.                                          (= (caddr condition) all-interrupts)))
  188.                                (write-line "(Enabling interrupts)"
  189.                                            (command-output)))
  190.                            (set-enabled-interrupts! all-interrupts))))
  191.               (let loop ()
  192.                 (let ((command (read-command-carefully (command-prompt)
  193.                                                        (form-preferred?)
  194.                                                        (command-input))))
  195.                   (showing-focus-object
  196.                    (lambda ()
  197.                      (execute-command command)))
  198.                   (loop))))))));;))
  199.  
  200. (define form-preferred?
  201.   (user-context-accessor 'form-preferred? (lambda () #t)))
  202.  
  203. ; Command level control
  204.  
  205. (define (pop-command-level)
  206.   (let ((levels (fluid $command-levels)))
  207.     (if (null? (cdr levels))
  208.         (if (or (batch-mode?)
  209.                 (y-or-n? "Exit the Scheme Shell" #t))
  210.             (exit-command-processor (lambda () 0))
  211.             (abort-to-command-level (car levels)))
  212.         (abort-to-command-level (cadr levels)))))
  213.  
  214. (define (abort-to-command-level level)
  215.   (throw-to-command-level
  216.        level
  217.        (lambda ()
  218.          (start-command-level
  219.           (lambda ()
  220.             (cond ((command-level-condition level)
  221.                    (display "Back to" (command-output)))
  222.                   ((null? (fluid $command-levels))
  223.                    (newline (command-output))
  224.                    (write-line "Top level" (command-output)))))
  225.           ;; Condition will be displayed.
  226.           level))))
  227.  
  228. (define (throw-to-command-level level thunk)
  229.   ((command-level-throw level) thunk))
  230.  
  231. (define (exit-command-processor thunk)
  232.   (throw-to-command-level (top-command-level)
  233.                           (lambda () thunk)))
  234.  
  235. ; Condition handler
  236.  
  237. (define (command-loop-condition-handler c next-handler)
  238.   (cond ((or (warning? c) (note? c))
  239.          (if (break-on-warnings?)
  240.              (deal-with-condition c)
  241.              (begin (display-condition c (command-output))
  242.                     (unspecific))))     ;proceed
  243.         ((or (error? c) (interrupt? c))
  244.          (if (batch-mode?)
  245.              (begin (display-condition c (command-output))
  246.                     (let ((status (if (error? c) 1 2)))
  247.                       (exit-command-processor (lambda () status))))
  248.              (deal-with-condition c)))
  249.         (else                           
  250.          (next-handler))))
  251.  
  252. (define push-command-levels?
  253.   (user-context-accessor 'push-command-levels (lambda () #t)))
  254. ;(define set-push-command-levels?!
  255. ;  (user-context-modifier 'push-command-levels))
  256.  
  257.  
  258. (define (deal-with-condition c)
  259.   (if (push-command-levels?)
  260.       (command-loop list c
  261.             ;; (interaction-environment)
  262.             )
  263.       (call-with-command-level c ;; (interaction-environment)
  264.         (lambda (level)
  265.           (set-focus-object! level)
  266.           (display-condition c (command-output))
  267.           (abort-to-command-level (car (fluid $command-levels)))))))
  268.  
  269.  
  270. (define-condition-type 'note '())
  271. (define note? (condition-predicate 'note))
  272.  
  273. (define (command-prompt)
  274.   (let ((level (- (length (fluid $command-levels)) 1))
  275.     (id (environment-id-string (environment-for-commands))))
  276.     (string-append (if (= level 0)
  277.                ""
  278.                (number->string level))
  279.            (if (or (= level 0) (= (string-length id) 0))
  280.                ""
  281.                " ")
  282.            id
  283.            "> ")))
  284.  
  285. (define-generic environment-id-string &environment-id-string (env))
  286.  
  287. (define-method &environment-id-string (env) "")
  288.  
  289.  
  290. ; Evaluate a form
  291.  
  292. (define (evaluate-and-select form env)
  293.   (call-with-values (lambda ()
  294.                       (evaluate form env))
  295.     (lambda results
  296.       (if (or (null? results)
  297.               (not (null? (cdr results)))
  298.               (not (eq? (car results) (unspecific))))
  299.           (set-focus-values! results))
  300.       (apply values results))))
  301.  
  302. (define-generic evaluate &evaluate (form env))
  303.  
  304. (define-method &evaluate (form env) (eval form env))
  305.  
  306.  
  307. ; Display the focus object if it changes (sort of like emacs's redisplay)
  308.  
  309. (define (showing-focus-object thunk)
  310.   (let ((focus-before (focus-values)))
  311.     (thunk)
  312.     (let ((focus-after (focus-values)))
  313.       (if (not (eq? focus-after focus-before))
  314.           (show-command-results focus-after)))))
  315.  
  316.  
  317. (define (focus-object)
  318.   (let ((v (focus-values)))
  319.     (if (and (pair? v) (null? (cdr v))) (car v) v)))
  320.  
  321. (define (set-focus-object! obj)
  322.   (set-focus-values! (list obj)))
  323.  
  324.  
  325. (define (show-command-results results)
  326.   (cond ((null? results))
  327.         ((not (null? (cdr results)))
  328.          (let ((out (command-output)))
  329.            (display "; " out)
  330.            (write (length results) out)
  331.            (display " values" out)
  332.            (newline out))
  333.          (for-each show-command-result results))
  334.         (else ;(not (eq? (car results) (unspecific)))
  335.          (show-command-result (car results)))))
  336.  
  337. (define (show-command-result result)
  338.   (write-carefully (value->expression result)
  339.                    (command-output))
  340.   (newline (command-output)))
  341.  
  342. (define $write-depth (make-fluid -1))
  343. (define $write-length (make-fluid -1))
  344.  
  345. (define (write-carefully x port)
  346.   (if (error? (ignore-errors (lambda ()
  347.                                (limited-write x port
  348.                                               (fluid $write-depth)
  349.                                               (fluid $write-length))
  350.                                #f)))
  351.       (display "<Error while printing.>" port)))
  352.  
  353.  
  354. ; Sentinels - run after every command.
  355.  
  356. (define *sentinels* '())
  357. (define (run-sentinels)
  358.   (for-each (lambda (sentinel) (sentinel)) *sentinels*))
  359. (define (add-sentinel! sentinel)
  360.   (if (not (memq sentinel *sentinels*))
  361.       (set! *sentinels* (cons sentinel *sentinels*))))
  362.  
  363.  
  364.  
  365. ; Commands.
  366.  
  367. (define command-environment
  368.   (user-context-accessor 'command-environment interaction-environment))
  369.  
  370. ;(define *command-structure* (unspecific))
  371. ;
  372. ;(define (command-structure)
  373. ;  *command-structure*)
  374. ;
  375. ;(define (set-command-structure! structure)  ; called on initial startup
  376. ;  (set! *command-structure* structure))
  377.  
  378. (define command-syntax-table (make-table))
  379. (define *command-help* '())
  380.  
  381. (define (get-command-syntax name)
  382.   (or (table-ref (user-command-syntax-table) name)
  383.       (table-ref command-syntax-table name)))
  384.  
  385. (define (define-command-syntax name help1 help2 arg-descriptions)
  386.   (table-set! command-syntax-table name arg-descriptions)
  387.   (if help1
  388.       (set! *command-help* (add-help *command-help* name help1 help2))))
  389.  
  390. (define (add-help help name help1 help2)  
  391.   (insert (list name
  392.                 (string-append (symbol->string name) " " help1)
  393.                 help2)
  394.           help
  395.           (lambda (z1 z2)
  396.             (string<=? (cadr z1) (cadr z2)))))
  397.  
  398. (define user-command-syntax-table
  399.   (user-context-accessor 'user-command-syntax-table (lambda () (make-table))))
  400.  
  401. (define user-command-environment
  402.   (user-context-accessor 'user-command-environment (lambda () #f)))
  403.  
  404. (define set-user-command-environment!
  405.   (user-context-modifier 'user-command-environment))
  406.  
  407. (define user-command-help
  408.   (user-context-accessor 'user-command-help (lambda () *command-help*)))
  409.  
  410. (define set-user-command-help!
  411.   (user-context-modifier 'user-command-help))
  412.  
  413. (define (define-user-command-syntax name help1 help2 arg-descriptions)
  414.   (table-set! (user-command-syntax-table) name arg-descriptions)
  415.   (if help1
  416.       (set-user-command-help!
  417.            (add-help (user-command-help) name help1 help2))))
  418.  
  419. (define (execute-command command)
  420.   (cond ((eof-object? command)
  421.          (newline (command-output))
  422.          (pop-command-level))
  423.         ((not command))       ; error while reading
  424.         (else
  425.          (let* ((name (car command))
  426.         (proc (evaluate name (user-command-environment))))
  427.        (dynamic-wind (lambda () #f)
  428.              (lambda ()
  429.                (apply proc (cdr command)))
  430.              run-sentinels)))))
  431.  
  432. ; help
  433.  
  434. (define (help . maybe-id)
  435.   (if (null? maybe-id)
  436.       (list-commands)
  437.       (print-command-help (car maybe-id))))
  438.  
  439. (define (print-command-help id)
  440.   (let ((o-port (command-output)))
  441.     (display #\space o-port)
  442.     (cond ((assq id (user-command-help))
  443.            => (lambda (data)
  444.                 (if (form-preferred?) (display command-prefix o-port))
  445.                 (display (cadr data) o-port)
  446.                 (display "    " o-port)
  447.                 (display (caddr data) o-port)))
  448.           (else
  449.            (display #\" o-port)
  450.            (display id o-port)
  451.            (display #\" o-port)
  452.            (display #\space o-port)
  453.            (display "is not a command.")))
  454.     (newline o-port)))
  455.  
  456. (define (list-commands)
  457.   (let ((o-port (command-output))
  458.         (widest 28)
  459.         (f? (form-preferred?)))
  460.     (for-each (lambda (s)
  461.                 (write-line s o-port))
  462.               '(
  463. "This is an alpha-test version of Scheme 48.  You are interacting with"
  464. "the command processor.  A command is either a Scheme form to evaluate"
  465. "or one of the following:"
  466. ""))
  467.  
  468.     (list-command-help (user-command-help) f? o-port)
  469.     (for-each (lambda (s)
  470.                 (write-line s o-port))
  471.               '(
  472. ""
  473. "Square brackets [...] indicate optional arguments."
  474. ""
  475. "The expression ## evaluates to the last value displayed by the command"
  476. "processor."
  477.                 ))))
  478.  
  479. (define (list-command-help data prefix? o-port)
  480.   (let* ((strings (map (if prefix?
  481.                            (lambda (d)
  482.                              (string-append (command-prefix-string
  483.                                              command-prefix)
  484.                                             (cadr d)))
  485.                            cadr)
  486.                        data))
  487.          (count (length strings))
  488.          (back-half (list-tail strings (quotient (+ 1 count) 2))))
  489.     (let loop ((s1 strings) (s2 back-half))
  490.       (cond ((not (eq? s1 back-half))
  491.              (display #\space o-port)
  492.              (display (car s1) o-port)
  493.              (write-spaces (max 1 (- 32 (string-length (car s1)))) o-port)
  494.              (if (not (null? s2))
  495.                  (display (car s2) o-port))
  496.              (newline o-port)
  497.              (loop (cdr s1) (if (null? s2) s2 (cdr s2))))))))
  498.                    
  499.  
  500. ; Utilities
  501.  
  502. (define (top-command-level)
  503.   (last (fluid $command-levels)))
  504.  
  505. (define (error-form proc args)
  506.   (cons proc (map value->expression args)))
  507.  
  508. (define (value->expression obj)         ;mumble
  509.   (if (or (number? obj) (char? obj) (string? obj) (boolean? obj))
  510.       obj
  511.       `',obj))
  512.  
  513. (define (write-spaces count o-port)
  514.   (do ((count count (- count 1)))
  515.       ((<= count 0))
  516.     (display #\space o-port)))
  517.  
  518. (define (command-prefix-string prefix)
  519.   (cond ((string? prefix) prefix)
  520.         ((char? prefix) (string prefix))
  521.         ((symbol? prefix) (symbol->string prefix))))
  522.  
  523. (define (write-line string port)
  524.   (display string port)
  525.   (newline port))
  526.  
  527.  
  528. (define (y-or-n? question eof-value)
  529.   (let ((i-port (command-input))
  530.         (o-port (command-output)))
  531.     (let loop ((count *y-or-n-eof-count*))
  532.       (display question o-port)
  533.       (display " (y/n)? " o-port)
  534.       (let ((line (read-line i-port)))
  535.         (cond ((eof-object? line)
  536.                (newline o-port)
  537.                (if (= count 0)
  538.                    eof-value
  539.                    (begin (display "I'll only ask another " o-port)
  540.                           (write count o-port)
  541.                           (display " times." o-port)
  542.                           (newline o-port)
  543.                           (loop (- count 1)))))
  544.               ((< (string-length line) 1) (loop count))
  545.               ((char=? (string-ref line 0) #\y) #t)
  546.               ((char=? (string-ref line 0) #\n) #f)
  547.               (else (loop count)))))))
  548.  
  549. (define *y-or-n-eof-count* 100)
  550.  
  551. (define (read-line port)
  552.   (let loop ((l '()))
  553.     (let ((c (read-char port)))
  554.       (if (eof-object? c)
  555.           c
  556.           (if (char=? c #\newline)
  557.               (list->string (reverse l))
  558.               (loop (cons c l)))))))
  559.  
  560.  
  561. (define (greet-user info)
  562.   (let ((port (command-output)))
  563.     (display "Welcome to Scheme 48 " port)
  564.     (display version-info port)
  565.     (if info
  566.         (begin (write-char #\space port)
  567.                (display info port)))
  568.     (display "." port)
  569.     (newline port)
  570.     (write-line "Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees."
  571.         port)
  572.     (write-line "Please report bugs to scheme-48-bugs@martigny.ai.mit.edu."
  573.                 port)
  574.     (if (not (batch-mode?))
  575.     (write-line "Type ,? (comma question-mark) for help." port))))
  576.  
  577.  
  578. (define (command-continuation)          ;utility for debugger
  579.   (let ((obj (focus-object)))
  580.     (command-level-vm-cont
  581.      (if (command-level? obj)
  582.          obj
  583.          (command-level)))))
  584.